home *** CD-ROM | disk | FTP | other *** search
/ BMUG Revelations / BMUG Revelations.toast / Programming / Programming Languages / Pocket 6.3 / Examples / Window&Menu < prev   
Encoding:
Text File  |  1993-06-13  |  6.7 KB  |  160 lines  |  [TEXT/McSk]
  1. ( Window&Menu for Pocket Forth 0.6.3 )
  2. ( Be sure that you are running this demo on a COPY of  )
  3. ( the Pocket Forth application [not the DA]. Close the )
  4. ( window if you need to quit and make a back up copy.  )
  5.  
  6. ( If this is a backup, press a key to continue.        )
  7. key drop
  8. page  0 28 +md !  ( turn off screen echo )
  9. forget task : task ; decimal
  10.  
  11. ( First define some general purpose words to create resources )
  12. ( Macros for memory manager )
  13. : >D0 ( n -- )
  14.        ,$ 4280 ,$ 301E ; macro  ( clr.l d0  move    [a6]+,d0 )
  15. : >A0 ( d -- ) ,$ 205E ; macro  (           movea.l [a6]+,a0 )
  16. : D0> ( -- n ) ,$ 3D00 ; macro  (           move    d0,-[a6] )
  17. : A0> ( -- d ) ,$ 2D08 ; macro  (           move.l  a0,-[a6] )
  18.  
  19. ( Memory management )
  20. : MERROR ( -- )  ( aborts on error in d0 )
  21.     d0> ?dup IF ." Memory Error:" . abort THEN ;
  22. : HNEW ( size -- handle )  ( create a new handle )
  23.     >d0 ,$ A122 a0> merror ;  ( _NewHandle )
  24. : HDISP ( handle -- ) >a0 ,$ A023 ;  ( _DisposHandle )
  25. : !HSIZE ( size handle -- )  ( set block size )
  26.     >a0 >d0 ,$ A024 merror ;
  27.  
  28. ( relocatable block definition )
  29. 2variable NBH 0 0 nbh 2!  ( New Block Handle holder )
  30. variable BOFFSET  0 boffset !  ( offset into the block )
  31. : ?B; ( -- flag )  ( true if "B;" is at here )
  32.     here 2@  578 = swap  15104 = and ;
  33. : BLOCK ( -- )  ( create a new 32K block )
  34.     0 boffset !  [ 32 1024 * literal ]  hnew  nbh 2! ;
  35. : :B ( -- ) ( compile numbers to the block with handle at nbh )
  36.     BEGIN
  37.       token ?b; 0= WHILE      ( while next word is not b;     )
  38.       here number IF          ( If it's a number              )
  39.         nbh 2@ dl@            (   dereference handle          )
  40.         boffset @ s>d d+  l!  (   store n at d.pointer+offset )
  41.         2 boffset +!          (   advance boffset             )
  42.       ELSE  nbh 2@ hdisp      ( not a number must be an error )
  43.         cr ." Data error at word: "  boffset @ . abort   THEN
  44.     REPEAT ;
  45. : EBLOCK ( -- dhandle )  ( finish a block creation )
  46.     boffset @ nbh 2@ !hsize  nbh 2@ ;
  47.  
  48. ( resource addition and removal )
  49. : RERROR ( -- )  ( check for resource error )
  50.     0 >r ,$ A9AF r> ?dup  ( _ResError )
  51.     IF ." Resource error: " . abort THEN ;
  52. : RGET ( id dtype -- dhandle )  ( get a resource handle )
  53.     0 0 2>r  2>r  >r  ,$ A9A0 2r> rerror ;  ( _GetResource )
  54. : RREMOVE ( dhandle -- ) 2>r ,$ A9AD ;  ( _RmveResource no err )
  55. : +RSC ( id dtype dhandle -- )  ( _AddResource to current file )
  56.     2>r 2>r >r 0 0 here 2! here a>r ,$ A9AB rerror ;
  57. : -RSC ( id dtype -- )  ( dispose of a resource )
  58.     rget 2dup rremove hdisp ;
  59.  
  60. hex  ( create the MENU resource )
  61. 4 ,s MENU -rsc ( remove any old MENU #4 )
  62. 4 ,s MENU  ( type of resource to create )
  63. block  ( put the following data into a relocatable block )
  64.     :b 0004 0000 0000 0000 0000 FFFF FFDB 0657 b;
  65.     :b 696E 646F 770B 4869 6465 2057 696E 646F b;  \ get these..
  66.     :b 7700 4800 0001 2D00 0000 000C 536D 616C b;  \ ..numbers..
  67.     :b 6C20 5769 6E64 6F77 0000 0000 0C4C 6172 b;  \ ...from...
  68.     :b 6765 2057 696E 646F 7700 0012 0001 2D00 b;  \ ..ResEdit
  69.     :b 0000 000B 5361 7665 2057 696E 646F 7700 b;
  70.     :b 4D00 0000 b;
  71. eblock +rsc  ( add a resource to Pocket Forth )
  72.  
  73. ( Now the resources are created and installed so the )
  74. ( resource creating and installing routines are not needed )
  75. decimal  forget task
  76.  
  77. ( Window pointer, menu handle and strings )
  78. : WINDOW ( -- window.pointer ) 0 +md 2@ ;
  79. 2variable SMENUH  ( to hold the handle to the menu )
  80. : ," ( -- ) ( compile a quoted string from input stream )
  81.     34 word here c@ 1+ dup 2 mod + allot ; IMMEDIATE
  82.  
  83. ( Show and hide the window, with toggling menu stuff. )
  84. create "HIDE" ," Hide Window"  ( string data )
  85. create "SHOW" ," Show Window"  ( string data )
  86. variable ?HIDDEN  0 ?hidden !
  87. : HIDE ( -- )
  88.     -1 ?hidden !
  89.     smenuh 2@ 2>r  1 >r  "show" a>r  ,$ A947  ( _SetItem )
  90.     window 2>r ,$ A916 ; ( _HideWindow )
  91. : SHOW ( -- )
  92.     0 ?hidden !
  93.     smenuh 2@ 2>r  1 >r  "hide" a>r  ,$ A947  ( _SetItem )
  94.     window 2>r ,$ A915 ; ( _ShowWindow )
  95. : HIDE/SHOW  ?hidden @ IF show ELSE hide THEN quit ;
  96.  
  97. ( Window size manipulation and menu checking )
  98. : WSIZE ( h v -- ) ( change the window size )
  99.     2dup  8 +md 2!  ( set the scroll rect )
  100.     window 2>r  2>r  256 >r  ,$ A91D ;  ( _SizeWindow )
  101. : WTINY ( -- )  ( make the window a two liner )
  102.      384  24 wsize  show
  103.      smenuh 2@ 2>r  3 >r  -1 >r  ,$ A945  ( _CheckItem 3 )
  104.      smenuh 2@ 2>r  4 >r  0 >r  ,$ A945 cr quit ;  ( [un]_CheckItem 4 )
  105. : WNORM ( -- )  ( bring back the normal sized window )
  106.      384 178 wsize  show
  107.      smenuh 2@ 2>r  4 >r  -1 >r  ,$ A945  ( _CheckItem 4 )
  108.      smenuh 2@ 2>r  3 >r  0 >r  ,$ A945 ;  ( [un]_CheckItem 3 )
  109.  
  110. ( Save the window's contents in a picture. )
  111. 4 +md constant WRECT  ( addr of window's rect )
  112. : WPICT ( -- dhandle ) ( the window picture's handle )
  113.     0 0 2>r  window 2>r ,$ A92F 2r> ;  ( _GetWindowPic )
  114. : KPIC ( d -- ) 2dup or IF 2>r ,$ A8F5 ELSE 2drop THEN ;
  115. : PICTURE ( rect -- dhandle ) ( open a picture leave its handle )
  116.     0 0 2>r  a>r  ,$ A8F3 2r> ;  ( _OpenPicture )
  117. : PCLOSE ( -- ) ,$ A8F4 ; macro  ( _ClosePicture )
  118. : PKILL ( addr -- ) 2@ kpic ; ( _KillPicture at addr )
  119. : WPASSIGN ( handle -- ) ( ASSIGN a Picture to Window )
  120.     window 2>r  2>r  ,$ A92E ;  ( _SetWindowPic )
  121. : BCOPY ( rect -- ) ( copy window bitmap to window )
  122.     window  2 0 d+ 2dup 2>r 2>r  ( window bits = source, destination )
  123.     dup a>r  a>r  0 >r  ( source rect, destination rect, mode )
  124.     window 24 0 d+ dl@ 2>r  ( mask to port visrgn )
  125.     ,$ A8EC ;  ( SrcCopy mode,  _CopyBits )
  126. : WSAVE ( -- ) ( save the screen for updating )
  127.     wpict kpic  ( _KillPicture )
  128.     0 0  window 148 0 d+  dl!  ( zero window picture in window record )
  129.     wrect picture  wpassign  wrect bcopy  pclose ;
  130.  
  131. ( Now create the menu arrays -- see Pocket Forth manual )
  132. create StuffMenu  ( a list of words for your menu items )
  133.     ' hide/show ,  ' null ,
  134.     ' wtiny ,  ' wnorm ,  ' null ,
  135.     ' wsave ,
  136.  
  137. create NewMenuList  ( a list of lists of your menubar )
  138.     18 +md @ @ ,     ( addr of existing File menu list )
  139.     18 +md @ 2+ @ ,  ( ditto for Edit menu list )
  140.     StuffMenu ,      ( and now Your menu )
  141.  
  142. : NUBYE  ( remove MENU resource before quitting )
  143.     smenuh 2@ 2>r  ,$ A9A3  ( _ReleaseResource )
  144.     0 0 2>r  ,s MENU 2>r 4 >r
  145.       ,$ A9A0 ,$ A9AD  ( _GetResource _RemoveResource )
  146.     bye ;  ( do the regular quit routine )
  147.     ' nubye 22 +md !  ( store this new quit routine )
  148.  
  149. : TASK ;  ( added 5/29/92 )
  150. : +MENU ( -- ) ( Turn the new menu on.)
  151.     NewMenuList 18 +md !  ( store the new menubar list )
  152.     0 0 2>r 4 >r ,$ A9BF  ( _GetRMenu )
  153.     2r> 2dup 2>r 0 >r ,$ A935  ( _InsertMenu )
  154.     smenuh 2!  ,$ A937 ;  ( _DrawMenuBar )
  155. +menu forget +menu
  156.  
  157. page  -1 28 +md !  ( turn on screen echo )
  158. ( Use the new “Windows” menu to manipulate the )
  159. ( Pocket Forth window.                         )
  160.